home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Modules / boot.em < prev    next >
Text File  |  1993-07-15  |  10KB  |  353 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: boot.em
  4. ;; Date: Sat Apr 11 19:05:09 1992
  5. ;;
  6. ;; Project:
  7. ;; Description:
  8. ;;   Module that contains functions necessary to boot
  9. ;;   the bytecode system successfully.
  10. ;;
  11. ;; Defines some useful functions, then
  12. ;; adds code suffient to create and install bindings into
  13. ;; modules.
  14.  
  15. (defmodule boot
  16.   (module-operators
  17.    bci
  18.    streams
  19.    macros0
  20.    (only (symbol-name) symbols)
  21.    )
  22.   ()
  23.  
  24.   (defconstant cons (compile-inline 2 (i-cons)))
  25.   (defconstant car (compile-inline 1 (slot-ref 0)))
  26.   (defconstant cdr (compile-inline 1 (slot-ref 1)))
  27.  
  28.   (defconstant set-car (compile-inline 2 (set-slot 0)))
  29.   (defconstant set-cdr (compile-inline 2 (set-slot 1)))
  30.  
  31.   (defconstant cadr (compile-inline 1 (slot-ref 1) (slot-ref 0)))
  32.   (defconstant cddr (compile-inline 1 (slot-ref 1) (slot-ref 1)))
  33.  
  34.   (defconstant vector-ref (compile-inline 2 (vref)))
  35.   (defconstant set-vector-ref (compile-inline 3 (set-vref)))
  36.  
  37.   (defconstant consp (compile-inline 1 (i-consp)))
  38.   (defconstant null (compile-inline 1 (nullp)))
  39.   (defconstant atom (compile-inline 1 (i-consp) (nullp)))
  40.   (defconstant eq (compile-inline 2 (eqp)))
  41.  
  42.   (defconstant list (compile-inline -1))
  43.   (defconstant assq (compile-inline 2 (i-assq)))
  44.   (defconstant memq (compile-inline 2 (i-memq)))
  45.   (defconstant scanq (compile-inline 2 (i-scanq)))
  46.   (defconstant identity (compile-inline 1))
  47.  
  48.   (defconstant bf-setter (compile-inline 1 (slot-ref 4)))
  49.   (defconstant bf-setter-setter (compile-inline 2 (set-slot 4)))
  50.  
  51.   (defconstant call-method-by-list (compile-inline 2 (swap) (apply-method-list)))
  52.   
  53.   (defconstant %do-apply (compile-inline 2 returning (apply-args)))
  54.  
  55.   (export cons car cdr set-car set-cdr cadr cddr vector-ref
  56.       set-vector-ref list null consp atom assq list
  57.       memq identity eq bf-setter call-method-by-list
  58.       %do-apply)
  59.  
  60.   (defconstant primitive-slot-ref-0 (compile-inline 1 (slot-ref 0)))
  61.   (defconstant primitive-slot-ref-1 (compile-inline 1 (slot-ref 1)))
  62.   (defconstant primitive-slot-ref-2 (compile-inline 1 (slot-ref 2)))
  63.   (defconstant primitive-slot-ref-3 (compile-inline 1 (slot-ref 3)))
  64.   (defconstant primitive-slot-ref-4 (compile-inline 1 (slot-ref 4)))
  65.   (defconstant primitive-slot-ref-5 (compile-inline 1 (slot-ref 5)))
  66.   (defconstant primitive-slot-ref-6 (compile-inline 1 (slot-ref 6)))
  67.   (defconstant primitive-slot-ref-7 (compile-inline 1 (slot-ref 7)))
  68.   (defconstant primitive-slot-ref-8 (compile-inline 1 (slot-ref 8)))
  69.   (defconstant primitive-slot-ref-9 (compile-inline 1 (slot-ref 9)))
  70.  
  71.  
  72.   (defconstant primitive-set-slot-ref-0 (compile-inline 2 (set-slot 0)))
  73.   (defconstant primitive-set-slot-ref-1 (compile-inline 2 (set-slot 1)))
  74.   (defconstant primitive-set-slot-ref-2 (compile-inline 2 (set-slot 2)))
  75.   (defconstant primitive-set-slot-ref-3 (compile-inline 2 (set-slot 3)))
  76.   (defconstant primitive-set-slot-ref-4 (compile-inline 2 (set-slot 4)))
  77.   (defconstant primitive-set-slot-ref-5 (compile-inline 2 (set-slot 5)))
  78.   (defconstant primitive-set-slot-ref-6 (compile-inline 2 (set-slot 6)))
  79.   (defconstant primitive-set-slot-ref-7 (compile-inline 2 (set-slot 7)))
  80.   (defconstant primitive-set-slot-ref-8 (compile-inline 2 (set-slot 8)))
  81.   (defconstant primitive-set-slot-ref-9 (compile-inline 2 (set-slot 9)))
  82.  
  83.   (export
  84.    primitive-slot-ref-0 
  85.    primitive-slot-ref-1
  86.    primitive-slot-ref-2 
  87.    primitive-slot-ref-3 
  88.    primitive-slot-ref-4 
  89.    primitive-slot-ref-5 
  90.    primitive-slot-ref-6 
  91.    primitive-slot-ref-7 
  92.    primitive-slot-ref-8 
  93.    primitive-slot-ref-9) 
  94.  
  95.   (export
  96.    primitive-set-slot-ref-0 
  97.    primitive-set-slot-ref-1
  98.    primitive-set-slot-ref-2 
  99.    primitive-set-slot-ref-3 
  100.    primitive-set-slot-ref-4 
  101.    primitive-set-slot-ref-5 
  102.    primitive-set-slot-ref-6 
  103.    primitive-set-slot-ref-7 
  104.    primitive-set-slot-ref-8 
  105.    primitive-set-slot-ref-9) 
  106.  
  107.   (set-bc-global 3 nil)
  108.  
  109.   ;; setup setter so we can use it nicely
  110.   (compile-declare bf-setter setter-function t)
  111.   (compile-add-callback bf-setter-setter setter-setter-function xx)
  112.   (export bf-setter-setter)
  113.   ;; fixup setter...
  114.   (bf-setter-setter bf-setter bf-setter-setter)
  115.   
  116.   ((bf-setter bf-setter) vector-ref set-vector-ref)
  117.   ((bf-setter bf-setter) car set-car)
  118.   ((bf-setter bf-setter) cdr set-cdr)
  119.  
  120.   ;; useful functions --- fold mapcar, reverse, mapc, member, append, mapcan, not
  121.   (defun fold (fn lst val)
  122.     (if (null lst) val
  123.       (fold fn (cdr lst)
  124.         (fn (car lst) val))))
  125.  
  126.   (defun mapcar1 (fn lst)
  127.     (if (null lst) nil
  128.       (let ((new-lst (list (fn (car lst)))))
  129.     (labels ((map-aux (l end)
  130.               (if (null l) nil
  131.                 (let ((newpair (list (fn (car l)))))
  132.                   ((bf-setter cdr) end newpair)
  133.                   (map-aux (cdr l) (cdr end))))))
  134.         (map-aux (cdr lst) new-lst))
  135.     new-lst)))
  136.  
  137.   (defun mapc1 (f l)
  138.     (if (null l) nil
  139.       (progn (f (car l))
  140.          (mapc1 f (cdr l)))))
  141.  
  142.   (defun member-list (x l f)
  143.     (cond ((null l) nil)
  144.       ((f x (car l)))
  145.       (t (member-list x (cdr l) f))))
  146.  
  147.   (defun append (a b)
  148.     (if (null a) b
  149.       (let ((lst (cons (car a) nil)))
  150.     (labels ((app-aux (l end)
  151.               (if (null l)
  152.                   end
  153.                 (let ((newpair (cons (car l) nil)))
  154.                   ((bf-setter cdr) end newpair)
  155.                   (app-aux (cdr l) newpair)))))
  156.         ((bf-setter cdr) (app-aux (cdr a) lst) b)
  157.         lst))))
  158.  
  159.   (defun nconc (a b)
  160.     (if (null a) b
  161.       (labels ((nconc-aux (l)
  162.               (if (cdr l)
  163.                   (nconc-aux (cdr l))
  164.                 (progn ((bf-setter cdr) l b) a))))
  165.           (nconc-aux a))))
  166.                   
  167.   '(defun mapcan (f l)
  168.      (if (consp l)
  169.      (nconc (f (car l))
  170.         (mapcan f (cdr l)))
  171.        nil))
  172.  
  173.   (defun mapcan (f l)
  174.     (labels ((mapcan-aux (eol lst)
  175.              (if (null lst) nil
  176.                (let ((new-lst (f (car lst))))
  177.                  (if (null new-lst)
  178.                  (mapcan-aux eol (cdr lst))
  179.                    (progn ((bf-setter cdr) eol new-lst)
  180.                       (mapcan-aux (last-pair new-lst) 
  181.                           (cdr lst)))))))
  182.          (last-pair (lst)
  183.             (if (atom (cdr lst))
  184.                 lst
  185.               (last-pair (cdr lst))))
  186.          (mapcan-aux-0 (lst)
  187.                (if (null lst) nil
  188.                  (let ((new-lst (f (car lst))))
  189.                    (if (null new-lst)
  190.                    (mapcan-aux-0 (cdr lst))
  191.                  (progn (mapcan-aux (last-pair new-lst)
  192.                             (cdr lst))
  193.                     new-lst))))))
  194.         (mapcan-aux-0 l)))
  195.  
  196.   ;;(defun mapcan (f l)
  197.   ;;(fold (lambda (x lst)
  198.   ;;(nconc lst (f x)))
  199.   ;;l
  200.   ;;nil))
  201.  
  202.   (defun not (x)
  203.     (null x))
  204.  
  205.   ;; Copied from  internals --- do not change!
  206.   (defconstant unbound-slot-value '%_*unbound*_%)
  207.  
  208.   ;; XXX: Should be inline
  209.   (defun scan-args (arg init-lst panic)
  210.     (let ((val (scanq arg init-lst)))
  211.       (if (eq val unbound-slot-value)
  212.       (panic arg init-lst)
  213.     val)))
  214.  
  215.  
  216.   (export fold mapcar1 mapc1 member-list append not scan-args nconc)
  217.  
  218.   ;; NB: No generic calls in this module
  219.  
  220.    ;; globals
  221.    (deflocal *mod-loc-list* nil)
  222.  
  223.    ;; include making TELOS here?
  224.  
  225.    ;; install this module....
  226.  
  227.  
  228.    (defun make-installed-module (name context)
  229.      (let ((mod (make-module name 0)))
  230.        (prin-object "{" t)
  231.        (setq *mod-loc-list* (cons (cons mod context) *mod-loc-list*))
  232.        (set-module-statics mod context)
  233.        mod))
  234.  
  235.    (defun all-registered-modules ()
  236.      *mod-loc-list*)
  237.  
  238.    (defun make-interface (mod if-desc)
  239.      (let ((import-desc (car if-desc))
  240.        (exports (cdr if-desc))
  241.        (strip-imports (eq (car (car if-desc)) 'strip)))
  242.        (mapc1
  243.     (if strip-imports
  244.         (lambda (x)
  245.           ;;(prin-object (module-name mod) t)
  246.           ;;(prin-object (car x) t)
  247.           ;;(prin-object "\n" t)
  248.           (if (memq (car x) exports)
  249.           (add-module-import mod
  250.                      (car x)
  251.                      (car (cdr x))
  252.                      (car (cdr (cdr x))))
  253.         nil))
  254.       (lambda (x)
  255.         (add-module-import mod
  256.                    (car x)
  257.                    (car (cdr x))
  258.                    (car (cdr (cdr x))))
  259.         nil))
  260.     (find-imports import-desc))
  261.        ;;(prin "{")
  262.        ;; Note that we forget where the hell it came from,
  263.        ;; but make sure it exists!
  264.        (mapc1 (lambda (x)
  265.            (if (dynamic-accessible-p mod x)
  266.            (add-module-export mod x)
  267.          nil))
  268.          exports)
  269.        (prin-object (symbol-name (module-name mod)) t)
  270.        (prin-object "}" t)
  271.        mod))
  272.  
  273.    (defun find-imports (ispec)
  274.      (cond ((eq (car ispec) 'import)
  275.         (find-module-exports (car (cdr ispec))))
  276.        ((eq (car ispec) 'union)
  277.         (mapcan (lambda (spec)
  278.               (find-imports spec))
  279.             (cdr ispec)))
  280.        ((eq (car ispec) 'except)
  281.         (let ((lst (car (cdr ispec))))
  282.           (fold (lambda (x l)
  283.               (if (memq (car x) lst)
  284.               l
  285.             (cons x l)))
  286.             (find-imports (car (cdr (cdr ispec))))
  287.             nil)))
  288.        ;; rename
  289.        ((eq (car ispec) 'rename)
  290.         (let ((rename-lst (car (cdr ispec)))
  291.           (imports (find-imports (car (cdr (cdr ispec))))))
  292.           (mapc1 (lambda (import)
  293.               (let ((xx (assq (car import) rename-lst)))
  294.             (if xx
  295.                 ((bf-setter car) import (car (cdr xx)))
  296.               nil)))
  297.             imports)
  298.           imports))
  299.        ;; only
  300.        ((eq (car ispec) 'only)
  301.         (fold (lambda (imp l)
  302.             (if (memq (car imp)
  303.                   (car (cdr ispec)))
  304.             (cons imp l)
  305.               l))
  306.           (find-imports (car (cdr (cdr ispec))))
  307.           nil))
  308.        ((eq (car ispec) 'strip)
  309.         (find-imports (car (cdr ispec))))
  310.        (t
  311.         ;;(print "Unknown import type")
  312.         ;;(print ispec)
  313.         nil)))
  314.  
  315.  
  316.    (defun find-module-exports (mod-name)
  317.      (let ((mod (get-module mod-name)))
  318.        (if (null mod)
  319.        (progn;;(prin "no module: ")
  320.          ;;(print mod-name)
  321.          nil)
  322.      (let ((lst (module-exports mod)))
  323.        (mapcar1 (lambda (name)
  324.              (list name mod name))
  325.            lst)))))
  326.  
  327.    (defun install-local-bindings (mod name-list loc-list)
  328.      (if (null name-list)
  329.      nil
  330.        (progn (add-module-binding mod (car name-list) (car loc-list))
  331.           (install-local-bindings mod (cdr name-list) (cdr loc-list)))))
  332.  
  333.    ;; used by initcode
  334.    (export make-interface make-installed-module install-local-bindings)
  335.  
  336.    ;; used by linker...
  337.    (export all-registered-modules)
  338.  
  339.    ;;(print "Boot Initialised.")
  340.    ;; end module
  341.    )
  342.  
  343.   (defun $boot ()
  344.     (let ((my-mod (make-module 'a)))
  345.       (make-interface 'b 'c)
  346.       ($boot-aux mod d)
  347.       ))
  348.  
  349.   (defun $boot-aux (mod names)
  350.     (if (null names)
  351.     mod
  352.       (set
  353.